home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / Modes / tclMode.tcl < prev    next >
Encoding:
Text File  |  2001-02-02  |  44.7 KB  |  498 lines
  1. ## -*-Tcl-*-
  2.  # # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "tclMode.tcl"
  6.  #                                    created: 5/4/97 {9:31:10 pm} 
  7.  #                                last update: 02/02/2001 {17:48:49 PM} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <vince@santafe.edu>
  10.  #    mail: 317 Paseo de Peralta
  11.  #          Santa Fe, NM 87501, USA
  12.  #     www: <http://www.santafe.edu/~vince/>
  13.  #  
  14.  # Copyright (c) 1997-2000 Vince Darley
  15.  #  
  16.  # Three procs from original: Tcl::DblClick listArray, getVarValue
  17.  #    
  18.  # Adds support for Tk, Itcl keywords and completions, plus 
  19.  # numerous fixes, improvements and integration with Vince's
  20.  # Additions.
  21.  # ###################################################################
  22.  ##
  23.  
  24. alpha::mode Tcl 1.9.3 tclMenu [list *.tcl *.itcl *.itk *.decls *.msg \
  25.   *.tbc tclIndex* "\\* Trace '*' \\*" *.test] {
  26.     tclMenu electricTab electricReturn electricBraces alphaDeveloperMenu
  27. } {
  28.     addMenu tclMenu "•269" "Tcl" "Tcl menu\r\rnot very obvious..."
  29.     set unixMode(wish) {Tcl}
  30.     set unixMode(tclsh) {Tcl}
  31.     set unixMode(itclsh) {Tcl}
  32.     set unixMode(itkwish) {Tcl}
  33.     set unixMode(prowish) {Tcl}
  34.     set unixMode(protclsh) {Tcl}
  35.     set unixMode(tclkit) {Tcl}
  36.     newPref sig tclshSig "WIsH"
  37.     ensureset evaluateRemotely 0
  38.     trace variable evaluateRemotely w tcltk::evaluateRemoteSynchronise
  39.     menu::buildProc tclMenu menu::buildtclMenu
  40.     lappend tclCmdColourings Tcl::colorTclKeywords \
  41.       Tcl::colorTkKeywords \
  42.       Tcl::colorItclKeywords Tcl::colorPseudoTclKeywords \
  43.       Tcl::colorTkCommands 
  44.     lappend tclExtraColourings \
  45.       Tcl::colorSymbols Tcl::colorMagicStrings
  46. } maintainer {
  47.     "Vince Darley" vince@santafe.edu <http://www.santafe.edu/~vince/>
  48. } uninstall this-file help {
  49.     This mode is for editing Tcl code.  You can edit code for internal
  50.     use with Alpha, or use Alpha as an external editor for code destined
  51.     for use with Tcl and Tk interpreters --- <http://www.tcltk.com>
  52.     distributes the Tclsh/Wish applications and a tcl-tk browser plugin.
  53.     <http://www.scriptics.com/> maintains a Tcl Developer's Xchange, and
  54.     is the best source for the latest Tcl/Tk releases.
  55.  
  56.     Most of Alpha(tk)'s functionality is contained in its Tcl library.  See
  57.     the "Tcl Example.tcl" file for an example.  You can 'evaluate' a
  58.     procedure (or any Tcl code for that matter) to make changes on the
  59.     fly.  If you select 'Evaluate Remotely' in the tcl-tk submenu, then
  60.     such actions will actually send the code to a separately running
  61.     Tclsh/Wish application to be evaluated.
  62.     
  63.     Alternatively, you can add .tcl files you wish to run in remote
  64.     interpreters to the tcl-tk submenu.  Selecting them will startup
  65.     a remote shell, source that .tcl file into it, and put Alpha(tk)
  66.     into 'remote' mode. Subsequent loading of code will go to the
  67.     remote shell automatically, so you can use Alpha to edit and
  68.     reload procedures in the remote shell, very simply.
  69.  
  70.     Alpha includes the help files "Tcl Commands", and "Tcl Resources".
  71. }
  72.  
  73. namespace eval tcltk {}
  74. proc tclMenu {} {}
  75.  
  76. # ◊◊◊◊ menu and prefs ◊◊◊◊ #
  77. # The menu.
  78. proc menu::buildtclMenu {} {
  79.     global tclMenu evaluateRemotely tcltk::executables
  80.     set execs {}
  81.     if {[info exists tcltk::executables]} {
  82.     lappend execs "\(-"
  83.     foreach ex ${tcltk::executables} {
  84.         lappend execs [file tail $ex]
  85.     }
  86.     }
  87.     set ma [list \
  88.       "/Levaluate" "/-<UswitchToTclsh" \
  89.       [list Menu -n "tcl-tk" -p tcltk::menuProc [concat [list \
  90.       "![lindex {{ } •} $evaluateRemotely]evaluateRemotely" \
  91.       executeCommand executeFileInRemoteShell addWindowToListOfExecutables] \
  92.       $execs]] \
  93.       "\(-" "/L<O<BreloadProc" "/I<O<BreformatProc" \
  94.       "rebuildTclIndexForWin" "debugProc" "applyChanges" "\(-" \
  95.       "<U/PfindProcDefinition…" "/Q<IquickFindProc…" "getVarValue…" \
  96.       "/4<BaddRemoveDollars" "/3<BinsertDivider" \
  97.       "\(-" "regularExpressionColors" "defaultColors"]
  98.     return [list build $ma Tcl::MenuProc "" $tclMenu]
  99. }
  100. menu::buildSome tclMenu
  101.  
  102. #===============================================================================
  103. #
  104. # Set up package-specific mode variables
  105. # 
  106.  
  107. # Removing obsolete preferences from earlier versions.
  108. prefs::removeObsolete TclmodeVars(alphaKeyWordColor) TclmodeVars(keywordColor) \
  109.   TclmodeVars(tclHelp)
  110.  
  111. newPref v prefixString {# } Tcl
  112. newPref f wordWrap {0} Tcl
  113. newPref v funcExpr {^proc *([-+a-zA-Z0-9:]+)} Tcl
  114. newPref v parseExpr {^proc *([-+a-zA-Z0-9:]+)} Tcl
  115. newPref v wordBreak {(\$)?[\w:_]+} Tcl
  116. newPref v wordBreakPreface {([^\w:_\$]|.\$)} Tcl
  117. newPref f autoMark 0 Tcl
  118. # Indentation scheme for lines following one ending in a backslash
  119. newPref v indentSlashEndLines 1 Tcl "" indent::amounts varindex
  120. # Mark files structurally, recognising the special comments
  121. # entered by 'ctrl-3'
  122. newPref f structuralMarks 0 Tcl
  123. # Cmd-double-clicking on a Tcl command will provide web-based documentation
  124. # from this location.
  125. newPref url tclHelpLocation "http://dev.scriptics.com/man/tcl8.4/TclCmd/" Tcl
  126.  
  127. newPref v procSearchPath "" Tcl
  128.  
  129. newPref f structuralElectricElseBrace 0 Tcl
  130.  
  131. set Tcl::startPara {^(.*\{)?[ \t]*(#|$)}
  132. set Tcl::endPara {^(.*\})?[ \t]*(#|$)}
  133. set Tcl::commentRegexp {^[ \t]*#}
  134.  
  135. # Not sure if this is used by completions still...
  136. set Tclcmds { append array catch close concat continue elseif error
  137. for foreach format lindex llength lrange lreplace lsearch lsort regexp 
  138. regsub rename return string switch while }
  139.  
  140. #===============================================================================
  141. #
  142. # Colorization setup
  143. #
  144.  
  145. # Colour Tk commands
  146. newPref f recogniseTk        {1}    Tcl    {Tcl::updateColors}
  147. # Colour [incr Tcl] commands
  148. newPref f recogniseItcl        {1}    Tcl    {Tcl::updateColors}
  149. # Recognise and colour some common procedures 'lunion' etc.
  150. newPref f recognisePseudoTcl    {1}    Tcl    {Tcl::updateColors}
  151. # Colour of all chosen commands.
  152. newPref color commandColor        {blue}    Tcl    {Tcl::updateColors}
  153. # Color for Tcl comments
  154. newPref color commentColor        {red}    Tcl    {Tcl::updateColors}
  155. # In Tcl, the colour of words started by '$'.  Tcl considers such 
  156. # words to be variables.  A dark brown might be a good choice, 
  157. # distinguishable, but not too distracting.  To try that, chose 
  158. # 'Config:Redefine Colors:Color_9' and set it to brown (the 'raw sienna'
  159. # crayon is a good choice). Then, when you are done, come back
  160. # to this dialog. Color_9 will now be available as a choice.
  161. newPref color magicColor        {black}    Tcl    {Tcl::updateColors}
  162. # Colour for strings
  163. newPref color stringColor        {green}    Tcl    {Tcl::updateColors}
  164. # Colour of symbols such as \, -, +, *, etc.  Can be useful for
  165. # reading regular expressions.
  166. newPref color symbolColor        {black}    Tcl    {Tcl::updateColors}
  167.  
  168. ## 
  169.  # -------------------------------------------------------------------------
  170.  # 
  171.  # "Tcl::_updateKeywords" --
  172.  # 
  173.  #  This proc now includes support for optional separate colorization of 
  174.  #  alpha commands. To use, set 'alphaKeyWordColor' to something other than 
  175.  #  'none' in the Tcl Mode Preferences dialog. -trf
  176.  # -------------------------------------------------------------------------
  177.  # 
  178.  # Now split into a series of procs, called in the end by colorizeTcl.  -cbu
  179.  # 
  180.  # -------------------------------------------------------------------------
  181.  ##
  182.  
  183. #===============================================================================
  184. #
  185. # Color procs begin here #
  186. #
  187.  
  188.  
  189. #===============================================================================
  190. #
  191. # Color Tcl Keywords
  192. #
  193.  
  194. proc Tcl::colorTclKeywords {} {
  195.     global TclmodeVars
  196.  
  197.     # all except beep and echo are basic Tcl keywords
  198.  
  199.     set tclKeyWords {
  200.     after append array auto_execok auto_import auto_load
  201.     auto_load_index auto_qualify beep binary break case catch cd clock
  202.     close concat continue dde default echo else elseif encoding eof
  203.     error eval exec exit expr fblocked fconfigure fcopy file
  204.     fileevent flush for foreach format gets glob global history if
  205.     incr info interp join lappend lindex linsert list llength load
  206.     lrange lreplace lsearch lsort namespace open package pid
  207.     pkg_mkIndex proc puts pwd read regexp regsub rename resource
  208.     return scan seek set socket source split string subst switch
  209.     tclLog tclMacPkgSearch tclPkgSetup tclPkgUnknown tell time
  210.     trace unknown unset update uplevel upvar variable vwait while
  211.     }
  212.     
  213.     regModeKeywords -a                \
  214.       -e {#} -c $TclmodeVars(commentColor)      \
  215.       -s $TclmodeVars(stringColor)              \
  216.       -k $TclmodeVars(commandColor) Tcl      \
  217.       $tclKeyWords 
  218.  
  219. }
  220.  
  221.  
  222.  
  223.  
  224. #===============================================================================
  225. #
  226. # Color Tk Keywords
  227. #
  228.  
  229. proc Tcl::colorTkKeywords {} {
  230.     global TclmodeVars
  231.  
  232.     set tkKeyWords {
  233.     bell bind bindtags button canvas checkbutton console destroy
  234.     entry event focus font frame grab grid image label listbox menu
  235.     menubutton message pack place radiobutton raise scale scrollbar
  236.     text tk tkwait toplevel winfo wm
  237.     }
  238.  
  239.     if {$TclmodeVars(recogniseTk)} {
  240.      regModeKeywords -a             \
  241.       -k $TclmodeVars(commandColor) Tcl    \
  242.       $tkKeyWords
  243.     } else {
  244.      regModeKeywords -a             \
  245.       -k {black} Tcl            \
  246.       $tkKeyWords
  247.     }
  248. }
  249.  
  250.  
  251. #===============================================================================
  252. #
  253. # Color iTcl Keywords
  254. #
  255.  
  256. proc Tcl::colorItclKeywords {} {
  257.     global TclmodeVars
  258.  
  259.     set itclKeyWords {
  260.     @scope body class code common component configbody constructor
  261.     define destructor hull import inherit itcl itk itk_component
  262.     itk_initialize itk_interior itk_option iwidgets keep method
  263.     private protected public
  264.     }
  265.  
  266.     if {$TclmodeVars(recogniseItcl)} {
  267.     regModeKeywords -a                 \
  268.      -k $TclmodeVars(commandColor) Tcl         \
  269.      $itclKeyWords
  270.    } else {
  271.     regModeKeywords -a                 \
  272.      -k {black} Tcl                     \
  273.      $itclKeyWords
  274.    }
  275. }
  276.  
  277.  
  278. #===============================================================================
  279. #
  280. # Color Pseudo Tcl Keywords
  281. #
  282.  
  283. proc Tcl::colorPseudoTclKeywords {} {
  284.     global TclmodeVars
  285.     
  286.     set PseudoTclKeywords { 
  287.     lcontains lunion lreverse lremove lunique
  288.     }
  289.     if {$TclmodeVars(recogniseTk)} {
  290.     regModeKeywords -a                 \
  291.      -k $TclmodeVars(commandColor) Tcl         \
  292.      $PseudoTclKeywords
  293.     } else {
  294.     regModeKeywords -a                 \
  295.      -k {black} Tcl                     \
  296.      $PseudoTclKeywords
  297.     }
  298.     
  299. }
  300.  
  301.  
  302. #===============================================================================
  303. #
  304. # Color Tk Commands
  305. #
  306. # add this line if we can handle double 'magic chars'
  307. # -m {tk} 
  308. #
  309.  
  310. proc Tcl::colorTkCommands {} {
  311.     
  312.     global TclmodeVars
  313.  
  314.     set TkCommands {
  315.     tkButtonDown tkButtonEnter tkButtonInvoke tkButtonLeave tkButtonUp
  316.     tkCancelRepeat tkCheckRadioInvoke tkDarken tkEntryAutoScan
  317.     tkEntryBackspace tkEntryButton1 tkEntryClosestGap tkEntryInsert
  318.     tkEntryKeySelect tkEntryMouseSelect tkEntryNextWord tkEntryPaste
  319.     tkEntryPreviousWord tkEntrySeeInsert tkEntrySetCursor
  320.     tkEntryTranspose tkEventMotifBindings tkFDGetFileTypes tkFirstMenu
  321.     tkFocusGroup_BindIn tkFocusGroup_BindOut tkFocusGroup_Create
  322.     tkFocusGroup_Destroy tkFocusGroup_In tkFocusGroup_Out tkFocusOK
  323.     tkListboxAutoScan tkListboxBeginExtend tkListboxBeginSelect
  324.     tkListboxBeginToggle tkListboxCancel tkListboxDataExtend
  325.     tkListboxExtendUpDown tkListboxMotion tkListboxSelectAll
  326.     tkListboxUpDown tkMbButtonUp tkMbEnter tkMbLeave tkMbMotion
  327.     tkMbPost tkMenuButtonDown tkMenuDownArrow tkMenuDup tkMenuEscape
  328.     tkMenuFind tkMenuFindName tkMenuFirstEntry tkMenuInvoke tkMenuLeave
  329.     tkMenuLeftArrow tkMenuMotion tkMenuNextEntry tkMenuNextMenu
  330.     tkMenuRightArrow tkMenuUnpost tkMenuUpArrow tkMessageBox
  331.     tkPostOverPoint tkRecolorTree tkRestoreOldGrab tkSaveGrabInfo
  332.     tkScaleActivate tkScaleButton2Down tkScaleButtonDown
  333.     tkScaleControlPress tkScaleDrag tkScaleEndDrag tkScaleIncrement
  334.     tkScreenChanged tkScrollButton2Down tkScrollButtonDown
  335.     tkScrollButtonUp tkScrollByPages tkScrollByUnits tkScrollDrag
  336.     tkScrollEndDrag tkScrollSelect tkScrollStartDrag tkScrollToPos
  337.     tkScrollTopBottom tkTabToWindow tkTearOffMenu tkTextAutoScan
  338.     tkTextButton1 tkTextClosestGap tkTextInsert tkTextKeyExtend
  339.     tkTextKeySelect tkTextNextPara tkTextNextPos tkTextNextWord
  340.     tkTextPaste tkTextPrevPara tkTextPrevPos tkTextResetAnchor
  341.     tkTextScrollPages tkTextSelectTo tkTextSetCursor tkTextTranspose
  342.     tkTextUpDownLine tkTraverseToMenu tkTraverseWithinMenu tk_bisque
  343.     tk_chooseColor tk_dialog tk_focusFollowsMouse tk_focusNext
  344.     tk_focusPrev tk_getOpenFile tk_getSaveFile tk_messageBox
  345.     tk_optionMenu tk_popup tk_setPalette tk_textCopy tk_textCut
  346.     tk_textPaste
  347.     }
  348.     
  349.     if {$TclmodeVars(recogniseTk)} {
  350.     regModeKeywords -a             \
  351.      -k $TclmodeVars(commandColor) Tcl     \
  352.      $TkCommands
  353.     } else {
  354.     regModeKeywords -a             \
  355.      -k {black} Tcl             \
  356.      $TkCommands   
  357.  
  358.     }
  359.     unset TkCommands    
  360. }
  361.     
  362. #===============================================================================
  363. #
  364. # Color Symbols
  365. # 
  366.  
  367. proc Tcl::colorSymbols {} {
  368.     
  369.     global TclmodeVars
  370.     
  371.     regModeKeywords -a                 \
  372.       -i "+" -i "-" -i "*" -i "_" -i "\\"    \
  373.       -I $TclmodeVars(symbolColor)              \
  374.       Tcl {}
  375. }
  376.  
  377.  
  378.     
  379. #===============================================================================
  380. #
  381. # Color variables (i.e. words prefaced by '$')
  382. # 
  383.  
  384. proc Tcl::colorMagicStrings {} {
  385.     
  386.     global TclmodeVars
  387.     
  388.     regModeKeywords -a                 \
  389.       -m {$}                    \
  390.       -k $TclmodeVars(magicColor) Tcl {}        
  391. }
  392.  
  393.  
  394. #===============================================================================
  395. #
  396. # Colorize Tcl
  397. # 
  398.  
  399. proc Tcl::colorizeTcl {} {
  400.     global tclCmdColourings tclExtraColourings 
  401.     foreach p $tclCmdColourings {
  402.     $p
  403.     }
  404.     # for some reason, these want to be done last -trf
  405.     foreach p $tclExtraColourings {
  406.     $p
  407.     }
  408.     refresh
  409. }
  410.  
  411. # This is a "dummy" command, necessary for the above proc so that all of
  412. # the "regModeKeywords" commands in the called color procs can be "adds"
  413. # (-a).  When the mode is first invoked, this has to occur before the color
  414. # procs are called.
  415.  
  416. regModeKeywords -k {none} Tcl {}
  417.  
  418. # now we finally colorize
  419.  
  420. Tcl::colorizeTcl
  421.  
  422.     
  423. #===============================================================================
  424. #
  425. # Tcl:: Update Colors -- 
  426. # 
  427. # This allows for changes to take effect without a restart.
  428. # 
  429. # Danger:  Don't include this proc in any {mode}Prefs.tcl file !!!
  430. # 
  431. # This will source the prefs file, and thus put Alpha in an endless loop.
  432. # Instead, use the  Tcl::colorizeTcl  proc in the prefs file, so that
  433. # "Load Prefs File" will update any local variables.     - cbu
  434. # 
  435.  
  436.  
  437. proc Tcl::updateColors {flag} {
  438.     
  439.     global mode PREFS $flag TclmodeVars 
  440.     
  441.     # If the mode has a {mode}Prefs.tcl file, we want to load that as 
  442.     # well, otherwise any keywords contained therein won't be updated
  443.     # without a manual "Load Prefs File".
  444.     
  445.     if {[file exists [file join ${PREFS} ${mode}Prefs.tcl]]} {
  446.     uplevel #0 [list source [file join ${PREFS} ${mode}Prefs.tcl]]
  447.     } 
  448.  
  449.     Tcl::colorizeTcl
  450. }
  451.  
  452. #===============================================================================
  453. #
  454. # Regular Expression Colors --
  455. # 
  456. # Changes color scheme of current window to make it easier to read regular
  457. # expressions.  Preferences aren't actually changed.  "defaultColors" will
  458. # restore to the last stored values of the colors.  -cbu
  459. # 
  460.  
  461. proc Tcl::regularExpressionColors {} {
  462.     
  463.     regModeKeywords -a                 \
  464.       -e {}                    \
  465.       -m {$}                    \
  466.       -s {black}                \
  467.       -k {magenta} Tcl {}            \
  468.       -i "+" -i "-" -i "*" -i "_" -i "\\"    \
  469.       -I {red}  
  470.     
  471.     refresh
  472. }
  473.  
  474. proc Tcl::defaultColors {} {Tcl::colorizeTcl}
  475.     
  476.  
  477. # ◊◊◊◊ end of keyword colorizing ◊◊◊◊ #
  478.  
  479. #===============================================================================
  480.  
  481.  
  482. proc Tcl::MenuProc {menu item} {
  483.     switch -glob $item {
  484.     "reformatProc" {
  485.         procs::reformatEnclosing [getPos]
  486.     }
  487.     "reloadProc" {
  488.         procs::loadEnclosing [getPos]
  489.     }
  490.     "debugProc" {
  491.         set func [procs::pick 1]
  492.         procs::debug $func
  493.     }
  494.     "applyChanges" {
  495.         set w [win::Current]
  496.         if {[regexp -- {\* Debug of (.*) \*( <[0-9]+>)?} $w "" proc]} {
  497.         set f [procs::searchFor $proc]
  498.         if {[string length $f]} {
  499.             if {![catch {procs::replace $f $proc 0}]} {
  500.             bringToFront $w
  501.             killWindow
  502.             }
  503.         } else {
  504.             message "Couldn't find $proc"
  505.         }
  506.         } else {
  507.         message "No debug window is foremost"
  508.         }
  509.     }
  510.     "findProcDefinition" {
  511.         procs::findDefinition
  512.     }
  513.     "quickFindProc" {
  514.         # use the status line
  515.         procs::quickFindDefn
  516.     }
  517.     "switch*" {
  518.         set v "[string tolower [string range $item 8 end]]Sig"
  519.         global $v
  520.         app::launchFore [set $v]
  521.     }
  522.     "addRemoveDollars" {
  523.         togglePrefix \$
  524.     }
  525.     default {
  526.         menu::generalProc Tcl $item 0
  527.     }
  528.     }
  529. }
  530.  
  531. # borrowed from Alphatk
  532. namespace eval alpha {}
  533.  
  534. proc alpha::inAlphaHierarchy {filename} {
  535.     global HOME PREFS tcl_platform
  536.     if {$tcl_platform(platform) == "windows"} {
  537.     set filename [file join [file attributes $filename -longname]]
  538.     } else {
  539.     set filename [file join $filename]
  540.     }
  541.     if {[file pathtype $filename] == "relative"} {
  542.     set filen [file join [pwd] $filename]
  543.     } else {
  544.     set filen $filename
  545.     }
  546.     # Is file in HOME or PREFS?
  547.     if {([string first [file join $HOME] $filen] != 0) \
  548.       && !([file type [file join $HOME]] == "link" \
  549.       && [string first [file readlink [file join $HOME]] $filen] == 0)} {
  550.     if {[info exists PREFS] && [file exists $PREFS]} {
  551.         if {([string first [file join $PREFS] $filen] != 0) \
  552.           && !([file type [file join $PREFS]] == "link" \
  553.           && [string first [file readlink [file join $PREFS]] $filen] == 0)} {
  554.         return 0
  555.         } else {
  556.         return 1
  557.         }
  558.     } else {
  559.         return 0
  560.     }
  561.     } else {
  562.     return 1
  563.     }
  564. }
  565.  
  566. ## 
  567.  # -------------------------------------------------------------------------
  568.  # 
  569.  # "Tcl::rebuildTclIndexForWin" --
  570.  # 
  571.  #  If the file is in Alpha's source tree, use the currently loaded
  572.  #  auto_mkindex.  If it is not, then fire up a separate Tcl application
  573.  #  and use its auto_mkindex (i.e. the standard Tcl one).  It just occured
  574.  #  to me that for Tcl >= 8.0, we could create a new interp, and 
  575.  #  execute auto_mkindex within that to the same effect, but without
  576.  #  the overhead of a whole new process (especially a Tk one!).
  577.  # -------------------------------------------------------------------------
  578.  ##
  579. proc Tcl::rebuildTclIndexForWin {} {
  580.     if {[alpha::inAlphaHierarchy [win::Current]]} {
  581.     auto_mkindex [file dirname [win::Current]]
  582.     auto_reset
  583.     } else {
  584.     # This will currently launch a Tk shell, which isn't ideal.
  585.     set dir [file dirname [win::Current]]
  586.     tcltk::launchNewShell "auto_mkindex $dir" "exit"
  587.     }
  588. }
  589.  
  590. proc tcltk::menuProc {menu item} {
  591.     global tcl_platform tclshSig
  592.     switch -- $item {
  593.     "evaluateRemotely" {
  594.         global evaluateRemotely
  595.         set evaluateRemotely [expr {1 - $evaluateRemotely}]
  596.     }
  597.     "executeFileInRemoteShell" {
  598.         tcltk::executeInRemoteShell [win::Current]
  599.     }
  600.     "addWindowToListOfExecutables" {
  601.         global tcltk::executables
  602.         lappend tcltk::executables [win::Current]
  603.         prefs::modified tcltk::executables
  604.         menu::buildSome tclMenu
  605.     }
  606.     "executeCommand" {
  607.         set cmd [getline "Please enter the script to send to tcl-tk"]
  608.         if {$cmd == ""} {return}
  609.         if {$tcl_platform(platform) == "macintosh"} {
  610.         set res [AEBuild -r -t 30000 '$tclshSig' misc dosc ---- "“$cmd”"]
  611.         } else {
  612.         set res [tcltk::evaluate $cmd]
  613.         }
  614.         alertnote "Result was '$res'"
  615.     }
  616.     default {
  617.         global tcltk::executables
  618.         foreach ex ${tcltk::executables} {
  619.         if {[file tail $ex] == $item} {
  620.             tcltk::executeInRemoteShell $ex
  621.             break
  622.         }
  623.         }
  624.     }
  625.     }
  626. }
  627.  
  628. proc tcltk::executeInRemoteShell {f} {
  629.     global evaluateRemotely
  630.     set realName [win::StripCount $f]
  631.     tcltk::launchNewShell \
  632.       "cd [file dirname $realName]" \
  633.       "source [file tail $realName]"
  634.     if {!$evaluateRemotely} {
  635.     set evaluateRemotely 1
  636.     }
  637. }
  638.  
  639. if {[info tclversion] < 8.0} {
  640.     proc tcltk::evaluateRemoteSynchronise {args} {
  641.     global evaluateRemotely tclMenu
  642.     catch {markMenuItem "tcl-tk" evaluateRemotely $evaluateRemotely}
  643.     if {$evaluateRemotely} {
  644.         if {[info commands notRemoteEvaluate] == ""} {
  645.         rename evaluate notRemoteEvaluate
  646.         ;proc evaluate {} {remoteEvaluate}
  647.         }
  648.         menu::replaceRebuild tclMenu "•320"
  649.     } else {
  650.         if {[info commands notRemoteEvaluate] != ""} {
  651.         rename evaluate {}
  652.         rename notRemoteEvaluate evaluate
  653.         }
  654.         menu::replaceRebuild tclMenu "•269"
  655.     }
  656.     }
  657. } else {
  658.     proc tcltk::evaluateRemoteSynchronise {args} {
  659.     global evaluateRemotely tclMenu
  660.     catch {markMenuItem "tcl-tk" evaluateRemotely $evaluateRemotely}
  661.     if {$evaluateRemotely} {
  662.         if {[info commands ::notRemoteEvaluate] == ""} {
  663.         rename ::evaluate ::notRemoteEvaluate
  664.         ;proc ::evaluate {} {remoteEvaluate}
  665.         }
  666.         menu::replaceRebuild tclMenu "•320"
  667.     } else {
  668.         if {[info commands ::notRemoteEvaluate] != ""} {
  669.         rename ::evaluate {}
  670.         rename ::notRemoteEvaluate ::evaluate
  671.         }
  672.         menu::replaceRebuild tclMenu "•269"
  673.     }
  674.     }
  675. }
  676.  
  677.  
  678. proc remoteEvaluate {} {
  679.     message "Remote reply: [tcltk::evaluate [getSelect]]"
  680. }
  681.  
  682. proc tcltk::quitRemote {} {
  683.     global tclshSig tcl_platform
  684.     if {$tcl_platform(platform) == "macintosh"} {
  685.     app::ensureRunning $tclshSig
  686.     if {[catch {set r [tclAE::build::resultData -t 30000 '${tclshSig}' \
  687.         misc dosc \
  688.         ---- [tclAE::build::TEXT exit] \
  689.         ]} res]} {
  690.         set res "Error: $res"
  691.     }            
  692.     } else {
  693.     global tclshInterp
  694.     if {![info exists tclshInterp]} {
  695.         if {[catch {tcltk::findTclshInterp}]} {
  696.         return "No shell selected"
  697.         }
  698.     }
  699.     if {$tcl_platform(platform) == "windows"} {
  700.         if {[dde services TclEval $tclshInterp] == ""} {
  701.         alertnote "The remote shell has died, please select a new one."
  702.         unset tclshInterp
  703.         return [tcltk::quitRemote exit]
  704.         }
  705.         catch {dde execute TclEval $tclshInterp "exit"}
  706.     } else {
  707.         catch {send $tclshInterp exit}
  708.     }
  709.     }
  710. }
  711.  
  712. proc tcltk::evaluate {what} {
  713.     global tclshSig tcl_platform
  714.     if {$tcl_platform(platform) == "macintosh"} {
  715.     app::ensureRunning $tclshSig
  716.     if {[catch {set r [tclAE::build::resultData -t 30000 '${tclshSig}' \
  717.                 misc dosc \
  718.               ---- [tclAE::build::TEXT $what] \
  719.             ]} res]} {
  720.         set res "Error: $res"
  721.     }            
  722.     #catch {dosc -c '${tclshSig}' -s $what} res
  723.     #return $res
  724.     } else {
  725.     global tclshInterp
  726.     if {![info exists tclshInterp]} {
  727.         if {[catch {tcltk::findTclshInterp}]} {
  728.         return "No shell selected"
  729.         }
  730.     }
  731.     if {$tcl_platform(platform) == "windows"} {
  732.         if {[dde services TclEval $tclshInterp] == ""} {
  733.         alertnote "The remote shell has died, please select a new one."
  734.         unset tclshInterp
  735.         return [tcltk::evaluate $what]
  736.         }
  737.         dde execute TclEval $tclshInterp [list catch $what alpha_result]
  738.         return [dde request TclEval $tclshInterp alpha_result]
  739.     } else {
  740.         catch {send $tclshInterp $what} res
  741.     }
  742.     }
  743.     return $res
  744. }
  745.  
  746. proc tcltk::listInterps {} {
  747.     global tcl_platform
  748.     if {$tcl_platform(platform) == "windows"} {
  749.     set res {}
  750.     foreach service [dde services TclEval ""] {
  751.         lappend res [lindex $service 1]
  752.     }
  753.     return $res
  754.     } else {
  755.     return [winfo interps]
  756.     }
  757. }
  758.  
  759. proc tcltk::findTclshInterp {} {
  760.     global tclshInterp tclshSigs tclshSig
  761.     set old [tcltk::listInterps]
  762.     set shel [listpick -p "Use which Tcl shell?" [concat $old \
  763.       [list "------------------" "Launch new shell"]]]
  764.     if {$shel == "Launch new shell"} {
  765.     tcltk::launchNewShell
  766.     } else {
  767.     set tclshInterp $shel
  768.     }
  769. }
  770.  
  771. ## 
  772.  # -------------------------------------------------------------------------
  773.  # 
  774.  # "tcltk::launchNewShell" --
  775.  # 
  776.  #  Startup up a new Tcl shell, ensuring that we can communicate with that
  777.  #  shell.  On Unix/MacOS this should be easy using 'send' or apple-events
  778.  #  respectively.  On Windows we have to set up the new shell as a dde
  779.  #  server.  We do this with the script 'winRemoteShell.tcl'.
  780.  #  
  781.  #  Any extra 'args' passed to this procedure are executed, one by one,
  782.  #  in the new shell.
  783.  # -------------------------------------------------------------------------
  784.  ##
  785. proc tcltk::launchNewShell {args} {
  786.     global tclshInterp tclshSigs tclshSig tcl_platform HOME
  787.     set old [tcltk::listInterps]
  788.     if {$tcl_platform(platform) == "windows"} {
  789.     app::runScript tclsh "Tcl shell" [file join $HOME Tools winRemoteShell.tcl] 2
  790.     } else {
  791.     app::launchElseTryThese $tclshSigs tclshSig "Please locate the remote Tcl application"
  792.     }
  793.     while {[tcltk::listInterps] == $old} {
  794.     update
  795.     }
  796.     set tclshInterp [lremove -l [tcltk::listInterps] $old]
  797.     # We're left with two items
  798.     set tclshInterp [lindex $tclshInterp 0]
  799.     
  800.     if {[llength $args]} {
  801.     foreach arg $args {
  802.         set res [tcltk::evaluate $arg]
  803.     }
  804.     return $res
  805.     }
  806.     return ""
  807. }
  808.  
  809. # ◊◊◊◊ Quick Find Proc… ◊◊◊◊ #
  810.  
  811. proc procs::quickFindDefn {} {
  812.     Tcl::DblClickHelper [prompt::statusLineComplete "proc" procs::complete]
  813. }
  814.  
  815. if {[info tclversion] < 8.0} {
  816.     proc procs::complete {pref} {
  817.     return [info commands ${pref}*]
  818.     }
  819. } else {
  820.     proc procs::complete {pref} {
  821.     if {[regexp {(.*)([^:]+)$} $pref "" start tail]} {
  822.         set cmds [info commands ${pref}*]
  823.         foreach child [namespace children ::$start] {
  824.         if {[string match "::${tail}*" $child]} {
  825.             foreach cmd [info commands ${start}${child}::*] {
  826.             lappend cmds [string trimleft $cmd :]
  827.             }
  828.         }
  829.         }
  830.         return $cmds
  831.     } else {
  832.         return [info commands ${pref}*]
  833.     }
  834.     }
  835. }
  836.  
  837. # ◊◊◊◊ electric behaviour ◊◊◊◊ #
  838. proc Tcl::electricLeft {} {
  839.     if {[literalChar]} { insertText "\{"; return }
  840.     set pat "\}\[ \t\r\n\]*(else(if)?)\[ \t\r\n\]*\$"
  841.     set p [getPos]
  842.     if { [set res [findPatJustBefore "\}" "$pat" $p word]] == "" } { 
  843.     insertText "\{"
  844.     return
  845.     }
  846.     # we have an if/else(if)/else
  847.     global structuralElectricElseBrace
  848.     # The behaviour here is optional, because some people may not
  849.     # like this more structured entry.
  850.     if {$structuralElectricElseBrace} {
  851.     switch -- $word {
  852.         "else" {
  853.         deleteText [lindex $res 0] $p
  854.         elec::Insertion "\} $word \{\r\t••\r\}\r••"
  855.         }
  856.         "elseif" {
  857.         deleteText [lindex $res 0] $p
  858.         elec::Insertion "\} $word \{••\} \{\r\t••\r\}\r••"
  859.         }
  860.     }
  861.     } else {
  862.     switch -- $word {
  863.         "else" {
  864.         replaceText [lindex $res 0] $p "\} $word \{\r"
  865.         bind::IndentLine
  866.         }
  867.         "elseif" {
  868.         replaceText [lindex $res 0] $p "\} $word \{"
  869.         }
  870.     }
  871.     }
  872. }
  873.  
  874. proc Tcl::electricRight {} {
  875.     if {[literalChar]} { insertText "\}"; return }
  876.     set p [getPos]
  877.     if { [regexp "\[^ \t\]" [getText [lineStart $p] $p]] } {
  878.     insertText "\}"
  879.     blink [matchIt "\}" [pos::math $p - 1]]
  880.     return
  881.     }
  882.     set start [lineStart $p]
  883.     insertText "\}"
  884.     createTMark tcl_er [getPos]
  885.     backwardChar
  886.     bind::IndentLine
  887.     gotoTMark tcl_er ; removeTMark tcl_er
  888.     bind::CarriageReturn
  889.     blink [matchIt "\}" [pos::math $start - 1]]
  890. }
  891.  
  892. ## 
  893.  # -------------------------------------------------------------------------
  894.  # 
  895.  # "Tcl::correctIndentation" --
  896.  # 
  897.  #  Returns the correct indentation for the line containing $pos, if that
  898.  #  line were to contain ordinary characters only.  It is the 
  899.  #  responsibility of the calling procedure to ensure that if we are to
  900.  #  insert/have a line already, that that information is taken into
  901.  #  account, by passing in the argument 'next'
  902.  # -------------------------------------------------------------------------
  903.  ##
  904. proc Tcl::correctIndentation {pos {next ""}} {
  905.     global indent_amounts indentSlashEndLines
  906.     # preliminaries
  907.     if {[pos::compare [set beg [lineStart $pos]] == [minPos]]} { return 0 }
  908.     # if the current line is a comment, we have to check some
  909.     # special cases
  910.     if {[string index $next 0] == "\#"} {
  911.     set p [prevLineStart $beg]
  912.     if {[catch {set p [search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^ \t\r\n\]" \
  913.       [pos::math $beg - 1]]}]} {
  914.         # check for search bug at beginning of file.
  915.         if {[pos::compare $p == [minPos]]} {
  916.         if {[getText [minPos] [pos::math [minPos] + 2]] == "\#\#"} {
  917.             if {([string range $next 0 1] != "\#\#")} {
  918.             return 1
  919.             } else {
  920.             return 0
  921.             }
  922.         }
  923.         }
  924.         return 0
  925.     }
  926.     set prev [pos::math [lindex $p 1] - 1]
  927.     set p [lindex $p 0]
  928.     if {[lookAt $prev] != "\#" || ($beg == [minPos])} {
  929.         # not a comment, so indent with code
  930.     } else {
  931.         set lwhite [posX $prev]
  932.         # it's a comment
  933.         if {[getText $prev [pos::math $prev + 2]] == "\#\#" && \
  934.           [lookAt [pos::math $prev + 2]] != "\#" \
  935.           && ([string range $next 0 1] != "\#\#")} {
  936.         # it's a comment paragraph
  937.         incr lwhite 
  938.         }
  939.     }
  940.     }
  941.     set next [string index $next 0]
  942.     if {![info exists lwhite]} {
  943.     if {![catch {search -s -f 0 -r 1 -i 0 -m 0 "^\[ \t\]*\[^\# \t\r\n\]" [pos::math $beg - 1]} lst]} {
  944.         # Find the last non-comment line and get its leading whitespace    
  945.         set lwhite [posX [pos::math [lindex $lst 1] - 1]]
  946.         set pe1 [lookAt [pos::math $beg - 2]]
  947.         set lst [lindex $lst 0]
  948.         set lastC [lookAt [lindex [search -s -f 0 -r 1 -i 0 -m 0 "\[^ \t\r\n\]" [pos::math [nextLineStart $lst] - 1]] 0]]
  949.         if {$next == "\}"} {
  950.         incr lwhite $indent_amounts(-2)
  951.         set pe2 [lookAt [pos::math [prevLineStart $beg] - 2]]
  952.         if {$pe1 == "\\"} {
  953.             incr lwhite $indent_amounts(1)
  954.         } else {
  955.             if {$pe2 == "\\"} {
  956.             incr lwhite $indent_amounts(-1)
  957.             }
  958.         }
  959.         if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  960.         } else { 
  961.         if {$pe1 == "\\"} {
  962.             if {[lookAt [pos::math [prevLineStart $beg] - 2]] != "\\"} {
  963.             incr lwhite $indent_amounts($indentSlashEndLines)
  964.             }
  965.         } else {
  966.             if {$lastC == "\{"} {incr lwhite $indent_amounts(2)}    
  967.             if {[lookAt [pos::math $lst - 2]] == "\\"} {
  968.             incr lwhite $indent_amounts(-$indentSlashEndLines)
  969.             }
  970.         }
  971.         }
  972.     } else {
  973.         # basically failed in all the above, so keep current indentation
  974.         set lwhite [posX [text::firstNonWsLinePos $beg]]
  975.     }
  976.     }
  977.     return [expr {$lwhite > 0 ? $lwhite : 0}]
  978. }
  979.  
  980. ## 
  981.  # -------------------------------------------------------------------------
  982.  #   
  983.  # "Tcl::indentLine" --
  984.  #  
  985.  #  Indentation for Tcl mode.  Better and faster than the generic procedure
  986.  # -------------------------------------------------------------------------
  987.  ##
  988. proc Tcl::indentLine {} {
  989.     set beg [lineStart [set p [getPos]]]
  990.     set text [getText $beg [nextLineStart $beg]]
  991.     regexp "^\[ \t\]*" $text white
  992.     set next [pos::math $beg + [string length $white]]
  993.     set nextp [pos::math $next + 2]
  994.     if {[pos::compare $nextp > [maxPos]]} {
  995.     set nextp [maxPos]
  996.     }
  997.     set lwhite [Tcl::correctIndentation [getPos] [getText $next $nextp]]
  998.     
  999.     set lwhite [text::indentOf $lwhite]
  1000.     if {$white != $lwhite} {
  1001.     replaceText $beg $next $lwhite
  1002.     }
  1003.     goto [pos::math $beg + [string length $lwhite]]
  1004.     # To keep relative position.
  1005.     #goto [pos::math $p + [string length $lwhite] - [pos::diff $beg $next]]
  1006. }
  1007.  
  1008. # ◊◊◊◊ Tcl Menu support ◊◊◊◊ #
  1009.  
  1010. proc procs::reformatEnclosing {pos} {
  1011.     set p [procs::findEnclosing $pos "proc|((itcl::)?(body|configbody))" 0 1]
  1012.     eval select $p
  1013.     ::indentRegion
  1014. }
  1015.  
  1016. proc procs::loadEnclosing {pos} {
  1017.     if {[catch {procs::findEnclosing $pos "proc|((itcl::)?(body|configbody))" 0 1} p]} {
  1018.     evaluateLine $pos
  1019.     } else {
  1020.     eval select $p
  1021.     if {[catch {uplevel \#0 evaluate} err]} {
  1022.         if {[regexp {can't create procedure "(.*)": unknown namespace} $err "" pr]} {
  1023.         if {[dialog::yesno "The procedure '$pr' couldn't be loaded, because\
  1024.           it is in an unknown namespace.  Shall I create the namespace and\
  1025.           try again?"]} {
  1026.             ensureNamespaceExists $pr
  1027.             return [procs::loadEnclosing $pos]
  1028.         }
  1029.         }
  1030.     }
  1031.     }
  1032.     goto $pos
  1033. }
  1034.  
  1035. proc procs::findDefinition {} {
  1036.     set func [procs::pick 1]
  1037.     editMark [procs::find $func] $func
  1038. }
  1039.  
  1040. ## 
  1041.  # -------------------------------------------------------------------------
  1042.  # 
  1043.  # "insertDivider" --
  1044.  # 
  1045.  #  Modified from Vince's original to allow you to just select part of
  1046.  #  an already written comment and turn it into a Divider. -trf
  1047.  # -------------------------------------------------------------------------
  1048.  ##
  1049. proc insertDivider {} {
  1050.     if {[isSelection]} {
  1051.     set enfoldThis [getSelect]
  1052.     beginningOfLine
  1053.     killLine
  1054.     insertText "# ◊◊◊◊ $enfoldThis ◊◊◊◊ #"
  1055.     return
  1056.     } 
  1057.     elec::Insertion "# ◊◊◊◊ •• ◊◊◊◊ #"
  1058. }
  1059.  
  1060. # ◊◊◊◊ Info providers ◊◊◊◊ #
  1061.  
  1062. proc Tcl::DblClick {from to shift option control} {
  1063.     
  1064.     # if cmd and cntrl were pressed, we look to select part of
  1065.     # a combination word (less any leading dollar sign) -trf
  1066.     if {$control != 0} {
  1067.     set clickedPos [getPos]    
  1068.     if {[lookAt $from] == "\$"} {
  1069.         set from [pos::math $from + 1]
  1070.     } 
  1071.     set sel_start $clickedPos 
  1072.     set selStartNotDetermined 1
  1073.     while {$selStartNotDetermined && ([pos::math $sel_start > $from])} {
  1074.         set char [lookAt $sel_start] 
  1075.         if {[regexp {_} $char]} {
  1076.         set sel_start [pos::math $sel_start + 1]
  1077.         set selStartNotDetermined 0
  1078.         } elseif {[regexp {[A-Z]} $char]} {
  1079.         set selStartNotDetermined 0
  1080.         } else {
  1081.         set sel_start [pos::math $sel_start -1]
  1082.         } 
  1083.     }
  1084.     set sel_end   $clickedPos 
  1085.     set selEndNotDetermined 1
  1086.     while {$selEndNotDetermined && ([pos::math $sel_end <= $to])} {
  1087.         set char [lookAt $sel_end] 
  1088.         if {[regexp "\[A-Z_ \t\r\]" $char]} {
  1089.         set selEndNotDetermined 0
  1090.         } else {
  1091.         set sel_end [pos::math $sel_end + 1]
  1092.         } 
  1093.     }
  1094.     select $sel_start $sel_end 
  1095.     return
  1096.     } 
  1097.     
  1098.     # otherwise, we try to impart some extra info
  1099.     select $from $to
  1100.     
  1101.     # if this was called using the shortcut key, the selection 
  1102.     # may include more than just the proc name, so we dust off
  1103.     # the selection first.
  1104.     set procName [getSelect] 
  1105.     set procName [string trimright $procName "'"]
  1106.     regexp -- "^proc\[ \t\]+(\[^ \t\]+)" $procName all procName 
  1107.     set procName [string trim $procName]
  1108.  
  1109.     # This might have been called from within a Trace window, 
  1110.     # in which case we want to move this window to the right
  1111.     # and push its mark.
  1112.     if {[regexp "^\\* (Tcl error|Trace|Stack)" [win::CurrentTail]]} {
  1113.     lappend selectionEndPoints [getPos] [selEnd]
  1114.     shrinkRight
  1115.     placeBookmark
  1116.     set got [search -s -n -f 1 -r 1 -m 0 -- \
  1117.       "\\(procedure \"[quote::Regfind $procName]\" line \[0-9\]+\\)" \
  1118.       [pos::math [getPos] -12]]
  1119.     if {[llength $got]} {
  1120.         eval select $got
  1121.         regexp "(\[0-9\]+)\\)\$" [getSelect] "" line
  1122.         if {![catch [list procs::debug $procName $line]]} {
  1123.         return
  1124.         }
  1125.     }
  1126.     set markSet 1
  1127.     } else {
  1128.     set markSet 0
  1129.     } 
  1130.     
  1131.     if {[catch [list Tcl::DblClickHelper $procName]]} {
  1132.     message "No docs $shift $control $option"
  1133.     } else {
  1134.     bringToFront [win::CurrentTail]
  1135.     }
  1136.     
  1137.     if {$markSet} {
  1138.     returnToBookmark
  1139.     eval select $selectionEndPoints 
  1140.     }
  1141. }
  1142.  
  1143.  
  1144. # Now finds commands in Alpha Commands,
  1145. # which has a <cr> immediately after them, e.g. beep, ticks.
  1146. proc Tcl::DblClickHelper {text} {
  1147.     global HOME auto_index auto_path TclmodeVars
  1148.     # Is it a loadable proc?
  1149.     if {[string length [set f [procs::find $text]]]} {
  1150.     if {[editMark $f $text]} {
  1151.         # some marking schemes commonly used for Tcl modes
  1152.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}\[ \t\]" [minPos]] 0]
  1153.     }
  1154.     return
  1155.     }
  1156.     
  1157.     if {[info exists "auto_index($text)"]} {
  1158.     if {[editMark "$auto_index($text)" $text]} {
  1159.         # some marking schemes commonly used for Tcl modes
  1160.         goto [lindex [search -s -f 1 -r 1 -m 0 -- "proc\[ \t\]+${text}\[ \t\]" [minPos]] 0]
  1161.     }
  1162.     return
  1163.     }
  1164.     # Is it a built-in Alpha command?
  1165.     set lines [grep "^• $text\( |\$)" [file join $HOME Help "Alpha Commands"]]
  1166.     if {[string length $lines]} {
  1167.     help::openFile "Alpha Commands"
  1168.     if {[catch {editMark [file join $HOME Help "Alpha Commands"] $text}]} {
  1169.         # mark failed for some reason, but we have the line number
  1170.         # anyway.
  1171.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  1172.     }
  1173.     setWinInfo read-only 1
  1174.     return
  1175.     }
  1176.     # Is it a core Tcl command?
  1177.     if {[info tclversion] >= 8.0} {
  1178.     interp create sub
  1179.     set res [sub eval "info commands $text"]
  1180.     interp delete sub
  1181.     if {[string length $res]} {
  1182.         url::execute "$TclmodeVars(tclHelpLocation)${text}.htm"
  1183.         return
  1184.     }
  1185.     }
  1186.     
  1187.     set lines [grep "^     $text -" [file join $HOME Help "Tcl Commands"]]
  1188.     if {[string length $lines]} {
  1189.     help::openFile "Tcl Commands"
  1190.     if {[catch {editMark [file join $HOME Help "Tcl Commands"] $text}]} {
  1191.         # mark failed for some reason, but we have the line number
  1192.         # anyway.
  1193.         goto [rowColToPos [string trimright [lindex [lindex [split $lines "\n"] 1] 3] :] 0]
  1194.     }
  1195.     setWinInfo read-only 1
  1196.     return
  1197.     }
  1198.     # Is it a global variable?
  1199.     if {[llength [info globals [string trimleft $text {$}]]]==1} {
  1200.     showVarValue [string trimleft $text {$}]
  1201.     return
  1202.     }
  1203.     # (becoming desperate) is it a mark in the current file?
  1204.     if {[lsearch [getNamedMarks -n] ${text}] != -1} {
  1205.     gotoMark $text
  1206.     return
  1207.     }
  1208.     error ""
  1209. }
  1210.  
  1211. #############################################################################
  1212. #  Report the current value of a global variable, chosen interactively
  1213. #  from a list of all active variables.
  1214. #
  1215. #  If the variable is an array, or its value is too big to fit in an 
  1216. #  alertnote, then its contents are listed in a new window, otherwise 
  1217. #  the variable's value is displayed in an alertnote.
  1218. #
  1219. proc getVarValue {} {
  1220.     if {[catch {getText [getPos] [selEnd]} def]} {set def ""}
  1221.     set var [getVarFromList $def]
  1222.     if {[string length $var] == 0} return
  1223.     showVarValue $var
  1224. }
  1225.  
  1226. if {[info tclversion] < 8.0} {
  1227.     
  1228.     proc getVarFromList {{def ""}} {
  1229.     return [listpick -p {Which var?} -L $def [lsort -ignore [info globals]]]
  1230.     }
  1231.     
  1232. } else {
  1233.     
  1234.     proc getVarFromList {{def ""}} {
  1235.     set ns "[namespace qualifiers $def]"
  1236.     set def [namespace tail $def]
  1237.     
  1238.     set items {}
  1239.     foreach var [info vars "${ns}::*"] {
  1240.         lappend items [namespace tail $var]
  1241.     }
  1242.     foreach space [namespace children $ns] {
  1243.         lappend items "[namespace tail $space]::"
  1244.     }
  1245.     
  1246.     set items [concat "::" [lsort -ignore $items]]
  1247.     set var [listpick -p "Which var in namespace ${ns}::?" -L $def $items]
  1248.     if {$var == "::"} {
  1249.         set var [getVarFromList $ns]
  1250.     } elseif {[namespace qualifiers $var] != ""} {
  1251.         set var [getVarFromList "${ns}::${var}"]
  1252.     } else {
  1253.         set var "${ns}::${var}"
  1254.     }
  1255.     return $var
  1256.     }
  1257. }
  1258.  
  1259. #############################################################################
  1260. #  Report the current value of a global variable, chosen interactively
  1261. #  from a list of all active variables.
  1262. #
  1263. #  If the variable is an array, or its value is too big to fit in an 
  1264. #  alertnote, then its contents are listed in a new window, otherwise 
  1265. #  the variable's value is displayed in an alertnote.
  1266. #
  1267. proc showVarValue {var} {
  1268.     global $var
  1269.     if {![array exists $var]} {
  1270.         viewValue $var [set $var]
  1271.     } else {
  1272.     new -n "* $var *" -info [listArray $var]
  1273.     # if 'shrinkWindow' is loaded, call it to trim the output window.
  1274.     catch {shrinkWindow 2}
  1275.     }
  1276. } 
  1277.  
  1278. #############################################################################
  1279. #  List the name and value of each element of the array $arrName.
  1280. #  (Convenient to use as a shell command.)
  1281. #
  1282. proc listArray {arrName} {
  1283.     global $arrName
  1284.     if {[array exists $arrName]} {
  1285.     set lines {}
  1286.         foreach nm [array names $arrName] {
  1287.             lappend lines "\"$nm\"\t\{[set ${arrName}($nm)]\}"
  1288.         }
  1289.         return [join $lines \r]
  1290.     } else {
  1291.         alertnote "\"$arrName\" doesn't exist in this context"
  1292.     }
  1293. }
  1294.  
  1295.  
  1296. proc 1xTop2xShowComment {} {
  1297.     global __1x2xShowPos
  1298.     
  1299.     ensureset __1x2xShowPos [minPos]
  1300.     set pos [getPos]
  1301.     # if we have a proc definition selected
  1302.     if {[regexp -- proc [getSelect]]} {
  1303.     set startCommentPos [procs::getCommentPos $pos]
  1304.     if {[pos::compare $__1x2xShowPos == $pos]} {
  1305.         # and, we already put it at the top
  1306.         if {[pos::compare $pos == $startCommentPos]} {
  1307.         message "           No comment for proc"
  1308.         } else {
  1309.         display $startCommentPos 
  1310.         }
  1311.         
  1312.         
  1313.     } else {
  1314.         # else, this is the first time the proc def is to be 
  1315.         # to be moved
  1316.         insertToTop
  1317.         set __1x2xShowPos [getPos]
  1318.         # just check and let user know if a comment is above
  1319.         # this proc.
  1320.         if {[pos::compare [getPos] == $startCommentPos]} {
  1321.         message "           No comment for proc"
  1322.         } else {
  1323.         message "Comments are above, press again to see them"
  1324.         }
  1325.     }
  1326.     
  1327.     } else {
  1328.     # user wants a normal line moved to the top
  1329.     insertToTop
  1330.     set __1x2xShowPos [minPos]
  1331.     }
  1332. }
  1333.  
  1334. Bind Clear 1xTop2xShowComment Tcl
  1335.  
  1336. # ◊◊◊◊ Marking ◊◊◊◊ #
  1337.  
  1338. ## 
  1339.  # -------------------------------------------------------------------------
  1340.  #     
  1341.  # "Tcl::parseFuncs" --
  1342.  #    
  1343.  # This proc is called by the "braces"    pop-up.    It returns a dynamically
  1344.  # created, alphabetical, list of "pseudo-marks".
  1345.  #    
  1346.  #    Author:    Tom Fetherston
  1347.  # -------------------------------------------------------------------------
  1348.  ## called by the "{}" button
  1349. proc Tcl::parseFuncs {} {
  1350.     global TclmodeVars
  1351.     set end [maxPos]
  1352.     set pos [minPos]
  1353.     set l {}
  1354.     set markExpr "^\[ \t\]*(itcl(::|_))?(class|body|proc|method|(config)?body)\[ \t\]"
  1355.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  1356.     set start [lindex $res 0]
  1357.     set end [nextLineStart $start]
  1358.     set t [getText $start $end]
  1359.     append t "\}"
  1360.     set argLabel {}
  1361.     regsub "^itcl(::|_)" [lindex $t 0] "" what
  1362.     switch -- [lindex $t 0] {
  1363.         "proc" {
  1364.         append argLabel [set word [lindex $t 1]]
  1365.         #get the list of arguments
  1366.         set argsList [lindex $t 2]
  1367.         if {[llength $argsList] > 0} {
  1368.             append argLabel " \{"
  1369.             foreach arg $argsList {
  1370.             if {[llength $arg] == 2 } {
  1371.                 append argLabel "¿"
  1372.             } elseif {[set arg] != "args"} {
  1373.                 append argLabel "•"
  1374.             } else {
  1375.                 append argLabel "…"
  1376.             }
  1377.             }
  1378.             append argLabel "\}"                    
  1379.         } 
  1380.         }
  1381.         default {
  1382.         append argLabel [set word [lindex $t 1]]
  1383.         }
  1384.     }
  1385.     if {[info exists cnts($word)]} {
  1386.         # This section handles duplicate. i.e., overloaded names
  1387.         incr cnts($word)
  1388.     } else {
  1389.         set cnts($word) 1
  1390.     }
  1391.     # if this is the only occurence of this proc, remember where it starts
  1392.     lappend indx($word) [lineStart [pos::math $start - 1]]
  1393.     # associate name and tag
  1394.     set tag($word) $argLabel
  1395.     
  1396.     # advance pos to where we want to start the next search from
  1397.     set pos $end
  1398.     }
  1399.     
  1400.     set rtnRes {}
  1401.     
  1402.     if {[info exists indx]} {
  1403.     foreach hn [lsort -ignore [array names indx]] {
  1404.         set num [llength $indx($hn)]
  1405.         if {$num > 1} {
  1406.         for {set i 0} {$i < $num} {} {
  1407.             set next [nextLineStart [lindex $indx($hn) $i]]
  1408.             incr i
  1409.             lappend rtnRes "$tag($hn) \($i of $num\)" $next
  1410.         }
  1411.         } else {
  1412.         set next [nextLineStart [lindex $indx($hn) 0]]
  1413.         lappend rtnRes $tag($hn) $next
  1414.         }
  1415.     }
  1416.     }
  1417.     return $rtnRes 
  1418. }
  1419.  
  1420. # called by the "M" button
  1421. proc Tcl::MarkFile {} {
  1422.     global structuralMarks
  1423.     set end [maxPos]
  1424.     set pos [minPos]
  1425.     set l {}
  1426.     if {$structuralMarks} {
  1427.     set markExpr {^[;     ]*(itcl(::|_))?(class|namespace eval|proc|method|(config)?body|# ◊◊◊◊)[     ]}
  1428.     } else {
  1429.     set markExpr {^[;     ]*(itcl(::|_))?(class|namespace eval|proc|method|(config)?body)[     ]}
  1430.     }
  1431.     set class ""
  1432.     set hasMarkers 0
  1433.     set already [list]
  1434.     while {![catch {search -s -f 1 -r 1 -m 0 -i 0 "$markExpr" $pos} res]} {
  1435.     set start [lindex $res 0]
  1436.     set end [nextLineStart $start]
  1437.     set t [string trim [getText $start $end] ";"]
  1438.     append t "\}"
  1439.     if {[catch {lindex $t 0}]} {
  1440.         # wasn't a well formed list
  1441.         set pos $end
  1442.         continue
  1443.     }
  1444.     regsub "^itcl(::|_)" [lindex $t 0] "" what
  1445.     switch -glob [string trim $what ";"] {
  1446.         "proc" -
  1447.         "configbody" { set text [lindex $t 1] }
  1448.         "method" { set text ${class}::[lindex $t 1] }
  1449.         "body" { 
  1450.         regexp {[a-zA-Z_][a-zA-Z_/0-9]*::[a-zA-Z_][a-zA-Z_/0-9]* } \
  1451.           "[lindex $t 1] " text
  1452.         }
  1453.         "namespace" {
  1454.         set ns [lindex $t 2]
  1455.         if {[regexp {[^a-zA-Z0-9]} $ns]} {
  1456.             set pos $end
  1457.             continue
  1458.         }
  1459.         set text "${ns} 111" 
  1460.         }
  1461.         "*class" { 
  1462.         set class [lindex $t 1]
  1463.         set text "${class} 000" 
  1464.         }
  1465.         "#" { 
  1466.         regexp "# ◊◊◊◊ (.*) ◊◊◊◊" $t all text
  1467.         if {[regexp "^(    )|(    )# ◊◊◊◊ " $t]} {
  1468.             set text " •$text"
  1469.         } else {
  1470.             set text "•$text"
  1471.         }                
  1472.         set hasMarkers 1
  1473.         }
  1474.     }
  1475.     set pos $end
  1476.     while { [lsearch -exact $already $text] != -1 } {
  1477.         set text "$text "
  1478.     }
  1479.     lappend already $text
  1480.  
  1481.     if {$structuralMarks} {
  1482.         lappend asEncountered $text
  1483.         set arr inds
  1484.     } else {
  1485.         if {[string index $t 0] == ";"} {
  1486.         set arr iinds
  1487.         } else {
  1488.         set arr inds
  1489.         }
  1490.     }
  1491.     set ${arr}($text) [lineStart [pos::math $start - 1]]
  1492.     }
  1493.     
  1494.     set class "#"
  1495.     foreach arr {inds iinds} {
  1496.     if {[info exists $arr]} {
  1497.         if {$arr == "iinds"} {
  1498.         # What is the goal of this line?
  1499.         setNamedMark "-" [minPos] [minPos] [minPos]
  1500.         }
  1501.         if {$structuralMarks} {
  1502.         set order $asEncountered
  1503.         } else {
  1504.         set order [lsort -ignore [array names $arr]]
  1505.         }
  1506.         foreach f $order {
  1507.         if {[set el [set ${arr}($f)]] != 0} {
  1508.             set next [nextLineStart $el]
  1509.         } else {
  1510.             set next 0
  1511.         } 
  1512.         
  1513.         if { [string first "000" $f] != -1 } {
  1514.             set ff "Class '[set class [lindex $f 0]]'"
  1515.         } elseif { [string first "111" $f] != -1 } {
  1516.             set ff "Namespace '[set class [lindex $f 0]]'"
  1517.         } elseif { [string first "${class}::" $f] == 0 } {
  1518.             set ff [string range $f [string length $class] end]
  1519.         } else {
  1520.             set ff $f
  1521.         }
  1522.         if {$hasMarkers && ![string match "•*" $ff] } {
  1523.             set ff " $ff"
  1524.         } 
  1525.         setNamedMark $ff $el $next $next
  1526.         }
  1527.     }
  1528.     }
  1529. }
  1530.  
  1531. # ◊◊◊◊ Misc. ◊◊◊◊ #
  1532.  
  1533. proc evaluateLine { pos } {
  1534.     goto $pos
  1535.     beginningLineSelect
  1536.     endLineSelect
  1537.  
  1538.     uplevel \#0 evaluate
  1539. }
  1540.  
  1541. tcltk::evaluateRemoteSynchronise
  1542.  
  1543.